home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
twu1.zip
/
TWU1UAM.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-06-03
|
70KB
|
2,045 lines
{$D+,L+,O-,S+,R-}
{ This Unit provides the tools needed for high-level analysis }
{ of desired units by the main program (TWU1). It is object }
{ oriented in its implementation but not in its interface. }
{ The intended user of this unit has relatively simple needs }
{ and no additional capabilities are provided. In particular }
{ the details of implementation including data structures are }
{ hidden from any potential user. The object methodology is }
{ not very spiritual. Neither inheritance nor virtual method }
{ techniques are employed, but static objects are utilized to }
{ assist with data management on the heap providing a highly }
{ structured environment for implementation. }
Unit TWU1UAM;
(*****************)
(**) INTERFACE (**) Uses TWU1EQU, TWU1RPT, Dos;
(*****************)
CONST
_UnitEye = 'TPU9'; { Identifies Units For TP60, TPW10 }
_Win_Lib = 'TPW.TPL'; { Turbo Pascal Unit Library - WINDOWS }
_Dos_Lib = 'TURBO.TPL'; { Turbo Pascal Unit Library - DOS }
Masker = $FFFFFFF0; { Paragraph AND Mask }
_Lib_Nam : _FileSpec = _Win_Lib; { Default to Windows Library }
{ Call Model Flag Bits }
Sstb_cmASM = $80; { Call Model: ASSEMBLER }
Sstb_cmDestructor = $50; { Call Model: DESTRUCTOR }
Sstb_cmConstructor = $30; { Call Model: CONSTRUCTOR }
Sstb_cmMethod = $10; { Call Model: METHOD- any }
Sstb_cmObject = $08; { $L OBJECT Mod (OBJ/OBW) }
Sstb_cmInterrupt = $04; { INTERRUPT Routine }
Sstb_cmINLINE = $02; { INLINE Declarative Macro }
Sstb_cmFAR = $01; { Call Model: FAR }
VAR Base_Code, { Logical Load Address for CODE Segments }
Base_Data, { Logical Load Address for CONS Segments }
Base_FixC, { Logical Load Address for CODE Fix-Ups }
Base_FixD: LongInt; { Logical Load Address for CONS Fix-Ups }
TYPE
_UnitName = String[8]; { Max Size of a Unit Name }
_LexName = String[63]; { Max Size of Pascal Names }
SrcNam = _FileSpec;
HdrAry = ARRAY[0..3] OF Char;
LL = Word; { Local Scope Locators (offsets) }
LG = RECORD { --Global Scope Locators to Other Units-- }
UntLL: LL; { To Entry in Unit Named by Type "Y" Entry }
UntId: LL; { To Stub of Type "Y" Name Entry }
END; {LG}
{ Mapping for Unit Header and Locator Table } {.CP28}
UnitPtr = ^UnitHeader;
UnitHeader = RECORD
UHEYE : HdrAry; { +00 : = 'TPU9' }
UHxxx : HdrAry; { +04 : = $00000000 }
UHUDH : LL; { +08 : to DName Entry for This Unit }
UHIHT : LL; { +0A : to Interface Hash Header }
UHPMT : LL; { +0C : to PROC Map }
UHCMT : LL; { +0E : to CSeg Map }
UHTMT : LL; { +10 : to DSeg Map-Typed CONST's }
UHDMT : LL; { +12 : to DSeg Map-GLOBAL Variables }
UHDLL : LL; { +14 : to DLL Module List }
UHLDU : LL; { +16 : to Donor Unit List }
UHLSF : LL; { +18 : to Source File List }
UHDBT : LL; { +1A : DEBUG Trace Table }
UHZDA : Word; { +1C : Size of DICTIONARY Area }
UHZCS : Word; { +1E : CSEG Size-Aggregate }
UHZDT : Word; { +20 : DSEG Size-Typed CONSTS Only }
UHZFA : Word; { +22 : Fix-Up Size (CSegs) }
UHZFT : Word; { +24 : Fix-Up Size (Typed CONST's) }
UHZFV : Word; { +26 : DSEG Size for Global VARs }
UHDHT : LL; { +28 : to Global Hash Header }
UHSOV : Word; { +2A : Flags ?? }
UHPad : ARRAY[0..9]
OF Word; { +2C : Reserved for Future Expansion ? }
END; { UnitHeader }
{ Mapping for PROC Map } {.CP12}
PMapRecPtr = ^PMapRec;
PMapRec = RECORD
ProcWd1, { purpose is unknown }
ProcWd2 : Word; { contains proc attribute flags? }
CSegOfs : Word; { offset within CSeg Map; $FFFF if null }
CSegJmp : Word; { offset to entry point; $FFFF if null }
END {PMapRec};
PMapPtr = ^PMapTab;
PMapTab = ARRAY[0..1] OF PMapRec; { model of PROC Map }
{ Mapping for CSeg Map } {.CP12}
CMapRecPtr = ^CMapRec;
CMapRec = RECORD
CSegWd0, { purpose is unknown }
CSegCnt, { byte count of module code }
CSegRel, { byte count of module Relo List }
CSegTrc : Word; { Trace table offset or $FFFF }
END; {CMapRec}
CMapTabPtr = ^CMapTab;
CMapTab = ARRAY[0..1] OF CMapRec; { model of CSeg Map }
{ Mapping for CONST/VAR DSeg Maps } {.cp12}
DMapRecPtr = ^DMapRec;
DMapRec = RECORD
DSegWd0 : Word; { purpose is unknown }
DSegCnt : Word; { byte count of DSeg block }
DSegRel : Word; { byte count of DSeg Relo List }
DSegOwn : LL; { To owner scope (VMT/DMT) }
END; {DMapRec}
DMapTabPtr = ^DMapTab;
DMapTab = ARRAY[0..1] OF DMapRec; { model of DSeg Map }
{ One Entry in CODE/DATA Fix-Up List } {.CP29}
FixUpRecPtr = ^FixUpRec;
FixUpRec = RECORD
Case Word Of
0: { -- Smart Linker Fix-Ups (Windows/Dos) -- }
(
FixDnr : Byte; { Donor Unit Offset }
FixFlg : Byte; { Entry Format Flag }
FixWd1 : Word; { Offset to Map Table }
FixWd2 : Word; { Effective Address Adjuster }
FixOfs : Word; { offset to patch in text block }
);
$FFFF: { -- Loader Fix-Ups For Windows 8087 Emulator -- }
(
EmuTag : Word; { $FFFF flags Emulator Fix-Up }
EmuTyp : Word; { Specific Emulator Fix-Up Type }
{ 2 = SS Override - (INT 3Ch : "ESC" = 18-1F) }
{ 3 = CS Override - (INT 3Ch : "ESC" = 58-5F) }
{ 4 = ES Override - (INT 3Ch : "ESC" = D8-DF) }
{ 5 = NO Override - (INT 34-3Bh : D8-DF) }
{ 6 = Emulate FWAIT Op ($909B) - (INT 3Dh) }
EmuEmt : Word; { Probably always zero }
EmuOfs : Word; { Offset to start of Emulated Op }
);
END; {FixUpRec}
FixUpPtr = ^FixUpList;
FixUpList = ARRAY[0..1] OF FixUpRec; { model of Fix-Up List }
{ Dictionary Name Entry Mapping in Turbo Units } {.CP08}
DNamePtr = ^ DNameRec;
DNameRec = RECORD
HLink : LL; { Hash Chain Link; Resolves Collisions }
DForm : Char; { Symbol Type; See StubRecord for types}
DSymb : _LexName; { Worst-Case Symbol Size (UPPER-CASE) }
END; {DNameRec}
{ Variant Type For TYPE "R" Dictionary Entry Stubs } {.CP20}
VarStubPtr = ^VarStub;
VarStub = RECORD
Case Byte Of { sRAM Byte in Type "R" Stub }
$02,$06,
$22,$26: (ROfs : Word; { allocation offset (BP) }
ROB : Word); { To Parent Scope/Zero }
$00,$01: (TOfs : Word; { allocation offset in map}
TOB : LL); { offset in VAR/CONST Map }
$03: (AOfs : Word; { Absolute Byte Offset }
ASeg : Word); { Absolute Segment Adr }
$08: (Bofs : Word; { Offset-Record Relative }
RChn : LL); { To Next Field/Method }
$10: (QLG : LG); { to Stub of Allocator }
End;
{ Dictionary Stub Mapping } {.CP10}
DStubPtr = ^ DStubRcd;
DStubRcd = RECORD
CASE Char OF
'R': ( { -- Variable, Field, Object -- } {.CP35}
sRAM : Byte; { allocation method codes: }
{ $00 = Global Variables in DS }
{ $01 = Typed Constants in DS }
{ $02 = VAR-BP based-Nested Scope }
{ $03 = Absolute[Segment:Offset] }
{ $06 = SELF Parameter-ADDR Stack }
{ $08 = Allocate in Record/Object }
{ $10 = Absolute Equivalence }
{ $22 = VALUE Parameter-BP based }
{ $26 = VAR Parameter-BP based }
sRVF : VarStub; { Don't have UNION - see Above! }
sRTD : LG); { to Type Descriptor }
'S': ( { ------ User Subprograms ----- } {.CP20}
sSTp : BYte; { 76543210 - BIT Encoded Flags }
{ .......1 = FAR Call Model }
{ ......1. = INLINE Declarative }
{ .....1.. = INTERRUPT Routine }
{ ....1... = .OBJ module code }
{ ...1.... = METHOD (Any) }
{ .011.... = Constructor METHOD }
{ .101.... = Destructor METHOD }
{ 1....... = ASSEMBLER attribute}
sSxx : Byte; { More Attribute Flags? }
sSPM : Word; { Code byte count if INLINE, }
{ else, offset to PROC Map }
sSPS : LL; { to containing scope or zero }
sSHT : LL; { to local scope hash table }
sSVM : Word); { VMT Offset-VIRTUAL Method PTR }
{ Note: "sSVM" is followed immediately by a Type }
{ Descriptor ($06). INLINE Declarative code }
{ Bytes then follow (if any). }
'Q', { -------- Named Types -------- } {.CP03}
'X':( { ----- External Variables ---- }
sQTD : LG); { to type descriptor }
'P':( { --- For Untyped Constants --- }
sPTD : LG; { to type descriptor }
sPV1 : Word; { value of constant - LO Word }
sPV2 : Word); { (size varies) - HI Word }
'Y':( { ----- For UNIT Entries ------ } {.CP05}
sYW1 : Word; { unknown use; normally zero }
sYCS : Word; { Unit Version Number }
sYNU : LL; { to next Unit in List (SUCC) }
sYPU : LL); { to prior Unit in List (PRED) }
'O', { ---- Label Declaratives ----- } {.CP05}
'T', { ---- Standard Procedures ---- }
'U', { ---- Standard Functions ---- }
'V':( { ---- Standard "NEW" F/P ---- }
sVxx : Word); { semantics not precisely known }
'W':( { ------- Standard Ports ------ } {.CP02}
sWxx : Byte); { 0=Byte Array, 1=Word Array }
END;
{ One Formal Parameter List Entry } {.CP06}
FormalParmRcd = RECORD
fPTD : LG; { to type descriptor for parameter }
fPAM : Byte; { passing model; 2=Value, 6=Address }
END;
InlineLst = ARRAY[0..1] OF Word; { model of INLINE code }
{ Type Descriptor mapping for Turbo Units follows } {.CP08}
TypePtr = ^TypeRecd;
TypeRecd = RECORD
tpTC : Byte; { Identifies the Variant Part }
tpTQ : Byte; { Type Qualifier }
tpSW : Word; { Storage Width in Bytes }
tpML : Word; { Next Method if tpTC=$06 }
CASE Byte OF {.CP04}
$00, { For NULL / Un-Typed Variables }
$0A, { COMP,DOUBLE,EXTENDED,SINGLE }
$0B: (); { ------- For REAL Type ------- }
$01: ( { ------ For ARRAY Types ------ }{.CP04}
BaseType: LG; { to TypeRecd for item arrayed }
BounDesc: LG; { to TypeRecd for array bounds }
);
$02: ( { ------ For RECORD Types ------ }{.CP04}
RecdHash: LL; { to Hash Table for Field List }
RecdDict: LL; { to Field List Dictionary Begin }
);
$03: ( { ------ For OBJECT Types ------ }{.CP15}
ObjtHash: LL; { to Fields & Methods Hash Table }
ObjtDict: LL; { to Fields & Methods Dictionary }
ObjtOwnr: LG; { to Parent Object Type Descript }
ObjtVMTs: Word; { Size of VMT if Virtual Methods }
ObjtDMap: Word; { Data Map Offset of VMT Template}
ObjtVMTO: Word; { object instance offset to VMT }
{ pointer; $FFFF if object has }
{ no Virtual Methods (no VMT) }
ObjtName: LL; { to Object Dictionary Header }
ObjtDMTp, { $FFFF or DMap Offset of DMT }
ObjtRes1, { Usually zero - Role Unknown }
ObjtRes2, { Usually zero - Role Unknown }
ObjtRes3: Word { Usually zero - Role Unknown }
);
$04, { ----- For FILE except TEXT ----} {.CP04}
$05: ( { ----- For TEXT file type ----- }
FileType: LG; { to TypeRecd for Base File Type }
);
$06: ( { ----- For Procedure Types ---- } {CP05}
PFRes: LG; { to Function Result TD / zero }
PNPrm: Word; { Formal Parameter Count/ zero }
PFPar: ARRAY[1..2] OF FormalParmRcd { model only }
);
$07: ( { ------- For SET Types -------- } {.CP03}
SetBase: LG; { to base type descriptor of set }
);
$08: ( { ----- For POINTER Types ------ } {.CP03}
PtrBase: LG; { to base type descriptor }
);
$09: ( { ------ For STRING Types ------ } {.CP04}
StrBase: LG; { to SYSTEM.CHAR type descriptor }
StrBound: LG; { to array bounds for string typ }
);
$0C, { For BYTE,INTEGER,LONGINT,SMALLINT,WORD } {.CP15}
$0D, { ------ For BOOLEAN Type ------ }
$0E, { ------- For CHAR Type -------- }
$0F: ( { ---- For Enumerated Types ---- }
LoBnd: LongInt; { lower bound of subrange }
HiBnd: LongInt; { upper bound of subrange }
Cmpat: LG; { to upward compatible Type desc }
);
{ The Enumeration Type Descriptor is immediately }
{ followed by a SET Type Descriptor ($07) but we }
{ don't know what this achieves. Its base type }
{ LG points to the Enumerated Type Descriptor. }
END; { TypeRecd }
{ The Record below is a model Hash Table } {.CP07}
HashPtr = ^HashTable;
HashTable = RECORD
Bas: Word; { Base and Max Offset in Slt }
Slt: ARRAY[0..63] Of LL; { Slots in Hash Table }
END;
{ The Record below maps a DLL List Entry - TPW Only} {.CP07}
DLLPtr = ^DLLList;
DLLList = Record
DLLWrk: Array[0..3] of Byte; { Work Area ? }
DLLMod: String[8]; { Module Name }
End;
{ One Entry in the Unit Code/Data Donor List } {.CP07}
UDonorPtr = ^UDonorRec;
UDonorRec = RECORD
UDExxx: Word;
UDEnam: String[8] { Name of Donor Unit }
END;
{ One Entry in the Source File List } {.CP11}
SrcFilePtr = ^SrcFileRec;
SrcFileRec = RECORD
SrcFlag: Byte; { 4=.PAS, 3=.INC, 5=.OBJ, 6=.RES }
SrcPad: Word; { no apparent use - always zero ? }
SrcTime: Word; { File Time Stamp if SrcFlag=3 or 4 }
SrcDate: Word; { File Date Stamp if SrcFlag=3 or 4 }
SrcName: SrcNam; { Varying length FileName.Extn }
{ (includes full path if TPWindows }
END;
{ One Entry in the Trace Table } {.CP12}
TraceRecPtr = ^TraceRec;
TraceRec = RECORD
TrName: LL; { to Directory Entry of Proc/Method }
TrFill: Word; { to proc source file }
TrPfx: Word; { bytes of data in front of code }
TrBeg: Word; { Line Number of BEGIN Stmt }
TrLNos: Word; { Lines of Code to Execute in TRACE }
TrExec: ARRAY[1..2] { Model Array of bytes that map each }
OF Byte; { line of code to be traced by DEBUG }
END;
FUNCTION AddrCMapTab(U: UnitPtr): CMapTabPtr; {.CP26}
Function AddrCodeArea(U: UnitPtr): Pointer;
FUNCTION AddrCodeFixUps(U: UnitPtr): FixUpPtr;
Function AddrDataArea(U: UnitPtr): Pointer;
FUNCTION AddrDataFixUps(U: UnitPtr): FixUpPtr;
FUNCTION AddrDict(U: UnitPtr; Hash: LL): DNamePtr;
FUNCTION AddrDLLTabOff(U: UnitPtr; Offset: Word): DLLPtr;
FUNCTION AddrDMapTab(U: UnitPtr): DMapTabPtr;
FUNCTION AddrHash(U: UnitPtr; Hash: LL): HashPtr;
FUNCTION AddrLGUnit(U: UnitPtr; TypeLG: LG): DNamePtr;
FUNCTION AddrNxtDLL(U: UnitPtr; Arg: DLLPtr): DLLPtr;
FUNCTION AddrNxtTrace(U: UnitPtr; T: TraceRecPtr): TraceRecPtr;
FUNCTION AddrPMapTab(U: UnitPtr): PMapPtr;
FUNCTION AddrProcType(S: DStubPtr): TypePtr;
FUNCTION AddrNxtSrc(U: UnitPtr; Arg: SrcFilePtr): SrcFilePtr;
FUNCTION AddrSrcTabOff(U: UnitPtr; Offset: Word): SrcFilePtr;
FUNCTION AddrStub(arg: DNamePtr): DStubPtr;
FUNCTION AddrTraceTab(U: UnitPtr): TraceRecPtr;
FUNCTION AddrType(U: UnitPtr; TypeLG: LG): TypePtr;
FUNCTION CountCMapSlots(U: UnitPtr): Integer;
FUNCTION CountDMapSlots(U: UnitPtr): Integer;
FUNCTION CountPMapSlots(U: UnitPtr): Integer;
FUNCTION FormLL(Base,Ceil: Pointer): LL;
FUNCTION GetTrExecSize(T: TraceRecPtr): Integer;
FUNCTION IsSystemUnit(U: UnitPtr): Boolean;
{ Function Below Removes PRIVATE Bit from Name Class } {.CP06}
FUNCTION Public(Arg: Char): Char;
{ BEGIN Public := Chr(Ord(Arg) AND $7F) END; }
INLINE( $58/ { POP AX }
$24/$7F); { AND AL,$7F }
{ -------------------------------------------------------- } {.CP04}
{ PurgeAllUnits - Removes all Units and Analyses from Heap }
Procedure PurgeAllUnits;
{ --------------------------------------------------------------- }{.CP05}
{ AnalyzeUnit - Loads and analyzes a Unit; references to Units }
{ it USES are resolved to clarify LG references }
Function AnalyzeUnit(Name: _UnitName; Path: String): UnitPtr;
{ --------------------------------------------------------------- }{.CP13}
{ ResolveLG - Checks all Directly referenced Units to locate }
{ the Unit and the Dictionary Entry for the owner }
{ of the Descriptor referenced by an LG provided }
{ AnalyzeUnit has been called before-hand }
Type
RespLG = Record { Returned by ResolveLG }
UPtr: UnitPtr; { Pointer to Named Unit }
Ownr: LL; { LL to Owner of LG'd Item }
End;
Procedure ResolveLG(N: _UnitName; L : LG; VAR R: RespLG);
{ ---------------------------------------------------------- } {.CP23}
{ FetchSurveyRec - is called to fetch the next SurveyRec }
{ to support formatted Dictionary printing }
{ of the primary Unit }
Type CoverId = (cvName, { Dictionary Entry Headers }
cvHash, { Hash Tables }
cvType, { Type Descriptors }
cvINLN, { INLINE Code Bytes }
cvNULL); { terminating status }
SurveyRecPtr = ^ SurveyRec; { Output of Survey }
SurveyRec = RECORD
LocLL : LL; { LL to location of data structure }
LocOwn : LL; { LL to Dictionary Header of Owner or 0 }
LocTyp : CoverId; { Class of Structure (see above) }
LocNxt : LL; { LL to location of following structure }
LocLvl : Word; { Nesting Level of entry }
End;
Procedure FetchSurveyRec (VAR S : SurveyRec); { Gets Dictionary Survey }
{ Results Sequentially }
{ ---------------------------------------------------------------- } {.CP53}
{ SortProcRefs - is called to sort the reference information for }
{ PROC Maps into either CSEG or PROC map order to }
{ print. BOTH sequences are used by TPU6. Only a }
{ Primary Unit gets these references built for it. }
{ }
{ FetchMapRef - is called to fetch a MapRefRec (see below) using }
{ the map offset. Only the primary Unit has such }
{ references constructed for it. }
Type
MapFlags = (mfNULL, { Undefined / Unused Entry }
mfINTF, { INTERFACE CONST/VAR Map Entry }
mfIMPL, { IMPLEMENTATION CONST/VAR Map }
mfNEST, { NESTED Scope Typed CONST DSeg }
mfXTRN, { EXTERNAL CONST/VAR DSeg }
mfTVMT, { VMT Template in CONST Map }
mfTDMT, { DMT Template in CONST Map }
mfPROC, { PROC Map Entry }
mfPRUI, { PROC Map Entry - Unit Init }
mfPDLL, { PROC Map Entry - DLL Proc }
mfCSEG); { CSEG Map Entry }
MapClass = (rPROC, { PROC Map }
rCSEG, { CSeg Map }
rVARS, { VARS Map - Global VAR DSeg Map }
rCONS); { CONS Map - Typed Constants Map }
MapRefRecPtr = ^ MapRefRec; { Output of VAR/CONST Map Survey }
MapRefRec = RECORD
MapTyp: MapFlags; { Defining Scope Category (see above) }
MapOfs: Word; { Offset within Map Table }
MapOwn: LL; { DNAME of Parent Scope / PROC }
MapSrc: Word; { Offset in Source File / DLL List }
MapLod: Word; { Load Point Segment Offset-CODE/CONST }
MapSiz: Word; { Size of Segment / PROC (Bytes) }
CASE MapFlags OF
mfCSEG: ( {--CSEG/CONST Map Table Only--}
MapFxI: Word; { Offset to Initial Fix-Up }
MapFxJ: Word; { Segment Fix-Up Byte Count }
);
mfPROC: ( {-----PROC Map Table Only-----}
MapEPT: Word; { Entry Point Offset for PROC }
MapCSM: Word; { Offset in CSEG Map for PROC }
);
mfPDLL: ( {-----PROC DLL Entry Only-----}
MapNdx: Word; { Index to DLL Entry Point }
MapDLL: Word; { Not Used at this time }
);
END;
SortMode = (CSegOrder, { Sort Proc Map into CSeg Order }
PMapOrder); { Sort Proc Map into Proc Order }
Procedure SortProcRefs (Mode: SortMode); { PROC Map Ref Sorts }
Procedure FetchMapRef (VAR S : MapRefRec; { Gets map references }
C : MapClass; { for the primary unit }
Offset: Word);
(**********************) {.CP03}
(**) IMPLEMENTATION (**)
(**********************)
{$IFDEF TESTDBG}
Uses Crt; { Used Only For Debugging }
{$ENDIF}
Type
UnitMode = (Entire,Partial);
TUnitPtr = ^ TUnit;
RMapPtr = ^ RMap;
MapTabPtr = ^ MapTab;
CvrPtr = ^ CvrTab;
CvrRecPtr = ^ CvrRec;
CvrRec = RECORD
LocLL : LL; { LL to location of data structure }
LocOwn : LL; { LL to Dictionary Header of Owner or 0 }
LocTyp : CoverId; { Type of Structure }
LocLvl : Word; { Entry Nesting Level in Dictionary }
END;
CvrTab = ARRAY[1..2] OF CvrRec; { Model of Queue }
MapTab = ARRAY[0..99] OF MapRefRec; { Model of Cross-Refs }
RMapVec = Array[MapClass] of RMapPtr;
LdrRec = Record
LdrSiz : Word;
LdrUpt : Pointer;
End;
LdrVec = Array[1..5] Of LdrRec; { Used by Segmented Loader }
{ ----------------------------------------------------- } {.CP38}
{ The TUnit Object is used to organize all information }
{ known about a Unit. It functions as an index node to }
{ allow reasonably fast access to a Unit by either name }
{ or by address. It provides links RMap objects which }
{ anchor "map" analyses. It contains the controls that }
{ manage the dictionary "cover" built for each Unit. }
{ ----------------------------------------------------- }
TUnit = Object
Link: TUnitPtr; { To Next TUnit in List }
UImg: UnitPtr; { To Unit Image on Heap }
UCod: ^Byte; { To UNIT CODE Segments }
UDta: ^Byte; { To Unit CONS Segments }
UFXC: FixUpRecPtr; { To Unit CODE Fix-Ups }
UFXD: FixUpRecPtr; { To Unit DATA Fix-Ups }
USiz: Word; { Allocated Image Size }
UCSz, { Allocated Code Size }
UDSz, { Allocated Data Size }
UFCz, { Allocated FXC Size }
UFDz: Word; { Allocated FXD Size }
Name: _UnitName; { Name for Fast Search }
CvrRMaps: RMapVec; { To Map Analyses }
CvrQue: CvrPtr; { To Completed Survey }
CvrSize: LongInt; { Allocation Size Bytes }
CvrLimit, { Queue Max Subscript }
CvrQueTail, { Cover Queue Tail }
CvrQueHead, { Cover Queue Head }
CvrQueMax: Word; { Cover Queue Ceiling }
Destructor Done;
Constructor Init(Id: _UnitName; Vector: LdrVec);
Procedure DisposeQueue;
Procedure CalcCovers;
Procedure IndexMaps;
FUNCTION QueuePos(Locn: LL): Word;
PROCEDURE EnQueue(Arg: CvrRec);
FUNCTION Queued(Key: LL) : Boolean;
End; { TUnit }
{ ----------------------------------------------------- } {.CP17}
{ The RMap Object is used to organize the information }
{ pertaining to Unit Map references. One such object }
{ is spawned for each Map type (CSeg,PROC,DSeg,CONST) }
{ and this object stores allocator information about }
{ the vector in which the references are stored. }
{ ----------------------------------------------------- }
RMap = Object
RMapTabPtr: MapTabPtr; { To Map References }
RMapTabSiz: Word; { Reference Counter }
Destructor Done;
Constructor Init(Width: Word);
Procedure SortPmap(Mode: SortMode);
Procedure FetchRef(VAR S: MapRefRec; Offset: Word);
Procedure StoreRef( S: MapRefRec; Offset: Word);
End;
Const RefLen = SizeOf(MapRefRec); MapLen = SizeOf(DMapRec);
LstRoot: TUnitPtr = Nil;
NullMap: MapRefRec = (MapTyp: mfNULL; MapOfs: 0;
MapOwn: $FFFF; MapSrc: 0;
MapLod: 0; MapSiz: 0;
MapEPT: 0; MapCSM: 0);
VAR CvrWork : CvrRec;
{$IFDEF TESTDBG}
VAR ExitSave: Pointer; Audit: Text;
Procedure MyExit; FAR;
Begin
ExitProc := ExitSave;
If TextRec(Audit).Mode <> fmClosed Then Close(Audit);
End;
{$ENDIF}
{ Begin Methods for R M a p } {.CP18}
Constructor RMap.Init(Width: Word);
Var I: Word; S: MapRefRec;
Begin
RMapTabPtr := Nil; RMapTabSiz := Width DIV SizeOf(DMapRec);
IF RMapTabSiz > 0 Then
Begin
GetMem(RMapTabPtr,RMapTabSiz * RefLen);
S := NullMap;
If RMapTabPtr = Nil Then RMapTabSiz := 0
Else
For I := 0 To RMapTabSiz-1 Do Begin
RMapTabPtr^[i] := S;
Inc(S.MapOfs,SizeOf(DMapRec));
End;
End;
End;
Destructor RMap.Done; {.CP05}
Begin
IF RMapTabSiz > 0 Then FreeMem(RMapTabPtr,RMapTabSiz * RefLen);
RMapTabPtr := Nil; RMapTabSiz := 0;
End;
Function CSegSort(Var pA, pB): Boolean; Far;
Var A : MapRefRec Absolute Pa; B : MapRefRec Absolute Pb;
Begin
CSegSort := False;
If (A.MapTyp <> mfPDLL) AND (B.MapTyp <> mfPDLL) Then
Begin
If A.MapCSM < B.MapCSM Then CSegSort := True
Else If A.MapCSM = B.MapCSM
Then If A.MapEPT < B.MapEPT Then CSegSort := True
End
Else CSegSort := Ord(A.MapTyp) < Ord(B.MapTyp)
End; {CSegSort}
Function PMapSort(Var pA, pB): Boolean; Far;
Var A : MapRefRec Absolute Pa; B : MapRefRec Absolute Pb;
Begin PMapSort := A.MapOfs < B.MapOfs End;
Procedure RMap.SortPmap(Mode: SortMode); {.CP25}
Var CompareProc: _Compare;
Begin {SortPMap} {.CP49}
If (RMapTabSiz > 1) AND (RMapTabPtr <> Nil) Then
Begin
Case Mode Of
CSegOrder: CompareProc := CSegSort;
PMapOrder: CompareProc := PMapSort;
End; {Case}
QuickSort( RMapTabPtr,
RMapTabSiz,
SizeOf(MapRefRec),
CompareProc);
End;
End; {SortPMap}
Procedure RMap.FetchRef(VAR S : MapRefRec; Offset : Word); {.CP10}
Var I : Word;
Begin
If (Offset MOD MapLen) = 0
Then I := Offset Div MapLen
Else I := RMapTabSiz;
If NOT (I < RMapTabSiz)
Then S := NullMap
Else S := RMapTabPtr^[I];
End;
Procedure RMap.StoreRef(S : MapRefRec; Offset : Word); {.CP09}
Var I : Word;
Begin
If (Offset MOD MapLen) = 0
Then I := Offset Div MapLen
Else I := RMapTabSiz;
If (I < RMapTabSiz)
Then RMapTabPtr^[I] := S
End;
{ Begin Methods For T U n i t } {.CP18}
Constructor TUnit.Init( Id: _UnitName; Vector: LdrVec);
Begin
Link := Nil; Name := Id; CvrQue := Nil;
CvrQueTail := 0; CvrQueHead := 0; CvrQueMax := 0;
CvrSize := 0; CvrLimit := 0;
CvrRMaps[rPROC] := Nil; CvrRMaps[rCSEG] := Nil;
CvrRMaps[rVARS] := Nil; CvrRMaps[rCONS] := Nil;
UImg := Vector[1].LdrUpt; USiz := Vector[1].LdrSiz;
UCod := Vector[2].LdrUpt; UCSz := Vector[2].LdrSiz;
UDta := Vector[3].LdrUpt; UDSz := Vector[3].LdrSiz;
UFxC := Vector[4].LdrUpt; UFCz := Vector[4].LdrSiz;
UFxD := Vector[5].LdrUpt; UFDz := Vector[5].LdrSiz;
End; {TUnit.Init}
Procedure TUnit.DisposeQueue; {.CP05}
Begin
If CvrQue <> Nil Then FreeMem(CvrQue,CvrSize);
CvrQue := Nil; CvrSize := 0; CvrLimit := 0;
End;
Destructor TUnit.Done; {.CP09}
Begin
DisposeQueue;
If CvrRMaps[rPROC] <> Nil Then CvrRMaps[rPROC]^.Done;
If CvrRMaps[rCSEG] <> Nil Then CvrRMaps[rCSEG]^.Done;
If CvrRMaps[rVARS] <> Nil Then CvrRMaps[rVARS]^.Done;
If CvrRMaps[rCONS] <> Nil Then CvrRMaps[rCONS]^.Done;
If UImg <> Nil Then FreeMem(UImg,USiz); UImg := Nil; USiz := 0;
If UCod <> Nil Then FreeMem(UCod,UCsz); UCod := Nil; UCsz := 0;
If UDta <> Nil Then FreeMem(UDta,UDsz); UDta := Nil; UDsz := 0;
If UFxC <> Nil Then FreeMem(UFxC,UFCz); UFxC := Nil; UFCz := 0;
If UFxD <> Nil Then FreeMem(UFxD,UFDz); UFxD := Nil; UFDz := 0;
End;
Function SearchCover(Key: LL; P: CvrPtr; Tail: Word): Word; {.CP21}
VAR Lo, Mid, Hi : Word;
BEGIN
Lo := 1; Hi := Tail;
REPEAT
ASM
XOR BX,BX { make a Zero }
MOV AX,Lo { fetch Lo }
ADD AX,Hi { Add Hi }
RCR BH,1 { save carry }
SHR AX,1 { divide sum by 2 }
OR AH,BH { restore carry }
MOV Mid,AX { save (Lo+Hi) DIV 2 }
End;
IF Key > P^[Mid].LocLL
THEN Lo := Mid + 1
ELSE Hi := Mid - 1
UNTIL (Key = P^[Mid].LocLL) OR (Lo > Hi);
IF Key > P^[Mid].LocLL THEN Inc(Mid);
SearchCover := Mid
End; {SearchCover}
FUNCTION TUnit.QueuePos(Locn : LL):Word; {.CP07}
VAR Lo, Mid, Hi : Word;
BEGIN
IF CvrQueTail < 1
THEN QueuePos := 1
ELSE QueuePos := SearchCover(Locn,CvrQue,CvrQueTail);
END; {QueuePos}
Procedure RaiseCover(Dest: Pointer; BytCnt, Slice: Word ); {.CP15}
ASSEMBLER;
ASM { ASM used for speed only - can be done with FOR Loop }
PUSH DS { Save DS for Turbo }
LES SI,Dest { ES = Seg(Dest^), SI = Ofs(Dest^) }
MOV CX,BytCnt { CX = Byte Count to Shift }
DEC SI { SI = Ofs(Dest^) - 1 }
MOV DI,Slice { DI = SizeOf(CvrRec) }
ADD DI,SI { DI = Ofs(Dest^) + SizeOf(CvrRec) - 1 }
MOV AX,ES { AX = Seg(Dest^) }
MOV DS,AX { DS = Seg(Dest^) }
STD { Set Direction Right-To-Left }
REPNZ MOVSB { Raise the queue }
POP DS { Restore DS for Turbo }
End; {RaiseCover}
PROCEDURE TUnit.EnQueue(Arg : CvrRec); {.CP31}
VAR Key : LL; Wide : LongInt; P, RP: ^CvrRec;
BEGIN
If CvrQue <> Nil Then
If CvrQueTail < CvrLimit Then
Begin
Key := QueuePos(Arg.LocLL);
RP := @CvrQue^[Key]; { merely a speed-up }
IF Arg.LocLL < UImg^.UHPMT THEN
IF Key > CvrQueTail THEN
BEGIN
Inc(CvrQueTail);
CvrQue^[CvrQueTail] := Arg
END ELSE
IF Arg.LocLL <> RP^.LocLL THEN { Raise higher entries to }
BEGIN { make room for insertion }
Inc(CvrQueTail);
P := @CvrQue^[CvrQueTail]; { merely a speed-up }
Wide := PtrDelta(P,RP);
RaiseCover(P, { Destination }
Wide, { Byte Count }
SizeOf(CvrRec)); { Entry Width }
RP^ := Arg
END;
If RP^.LocLvl > Arg.LocLvl Then RP^.LocOwn := Arg.LocOwn Else
If RP^.LocLvl = Arg.LocLvl Then
If RP^.LocLL > Arg.LocLL Then RP^.LocOwn := Arg.LocOwn;
IF CvrQueTail > CvrQueMax THEN CvrQueMax := CvrQueTail;
End;
END; {EnQueue}
FUNCTION TUnit.Queued(Key : LL):Boolean; {.CP12}
VAR Loc : Word;
BEGIN
Queued := False;
If CvrQue <> Nil Then
If CvrQueTail > 0 Then
Begin
Loc := QueuePos(Key);
IF Loc <= CvrQueTail
THEN Queued := Key = CvrQue^[Loc].LocLL
End;
END; {Queued}
Procedure TUnit.CalcCovers; {.CP04}
Const LvlLim = 256;
Var Level: Word; QueLoad : Boolean; ECount: Longint;
USymbol: _LexName; A: CvrRec; LvlSav : Array[1..LvlLim] of LL;
{$IFDEF TESTDBG} {.CP19}
Procedure CoverFault(Loc:LL);
Begin
WriteLn;
WriteLn('Fault -- Unit: ',Name,', Loc: ',HexW(Loc));
WriteLn('Last Name: ',USymbol);
WriteLn('Level: ',Level,', ECount: ',ECount);
Loc := LL(ReadKey);
End;
Procedure CoverAudit(A: String; B: Word);
Begin
If NOT QueLoad Then
WriteLn(Audit,'Unit: ',name,', Loc: ',HexW(B),
', Lvl: ',HexW(Level),', Entry: ',HexW(ECount),
', Proc: ',A);
End;
{$ENDIF}
PROCEDURE CoverWrapUp;
PROCEDURE CoverWrapPost(Loc,s:LL); {.CP10}
VAR J : LL;
BEGIN
j := QueuePos(s);
If CvrQue <> Nil Then
WITH CvrQue^[j] DO
IF LocLL = s THEN
IF (LocOwn > Loc) OR (LocOwn = 0)
THEN LocOwn := Loc;
END; {CoverWrapPost}
PROCEDURE CoverWrapType(Loc: LL); {.CP31}
VAR D : DNamePtr; S : DStubPtr; T : TypePtr; i,j,k : LL;
RP : VarStubPtr; DF : Char;
BEGIN
{$IFDEF TESTDBG}
If (Loc < UImg^.UHIHT) OR (Loc > UImg^.UHPMT)
Then CoverFault(Loc);
{$ENDIF}
D := AddrDict(UImg,Loc); { Q entry }
S := AddrStub(D); { its stub }
RP := @S^.sRVF;
T := AddrType(UImg,S^.sQTD);
IF T <> Nil THEN { TD in this unit }
BEGIN
DF := Public(D^.DForm);
CoverWrapPost(Loc,S^.sQTD.UntLL);
IF (T^.tpTC = 2) OR (T^.tpTC = 3) THEN
BEGIN
i := T^.RecdDict;
IF i <> Loc THEN
WHILE i <> 0 DO BEGIN
CoverWrapPost(Loc,i);
D := AddrDict(UImg,i);
S := AddrStub(D);
IF DF = 'R' THEN i := RP^.ROB ELSE
IF DF = 'S' THEN i := S^.sSHT
ELSE i := 0;
END {While I}
END
END {IF T <> Nil}
END; {CoverWrapType}
VAR i : Word; {.CP09}
BEGIN {CoverWrapUp}
If CvrQue <> Nil Then
For i := 1 TO CvrQueTail DO
WITH CvrQue^[i] DO
IF LocTyp = cvName THEN
IF Public(AddrDict(UImg,LocLL)^.DForm) = 'Q'
THEN CoverWrapType(LocLL)
END; {CoverWrapUp}
PROCEDURE CoverHash(Loc, Own: LL); FORWARD; {.CP15}
Procedure CoverInline(Loc,Own: LL);
Begin
{$IFDEF TESTDBG}
CoverAudit('CoverInLine',Loc);
{$ENDIF}
If NOT QueLoad
Then Inc(ECount) Else
Begin
A.LocLL := Loc; A.LocOwn := Own;
A.LocTyp := cvINLN; A.LocLvl := Level;
Enqueue(A);
End;
End; {CoverInline}
PROCEDURE CoverType(Loc, Own: LL); {.CP23}
VAR T, TT : TypePtr;
Procedure CoverTypeTry(ALG: LG; Loc, Own: LL);
Begin
If AddrType(UImg,ALG) <> Nil THEN
IF ALG.UntLL <> Loc THEN
CoverType(ALG.UntLL,Own);
End;
BEGIN {CoverType}
{$IFDEF TESTDBG}
If (Loc < UImg^.UHIHT) OR (Loc > UImg^.UHPMT)
Then CoverFault(Loc);
CoverAudit('CoverType',Loc);
{$ENDIF}
If NOT QueLoad
Then Inc(ECount) Else
Begin
A.LocLL := Loc; A.LocOwn := Own;
A.LocTyp := cvType; A.LocLvl := Level;
Enqueue(A);
End;
T := TypePtr(PtrAdjust(UImg,Loc));
IF T <> Nil THEN
WITH T^ DO {.CP36}
CASE tpTC OF
$01: BEGIN
CoverTypeTry(BaseType,Loc,Own);
CoverTypeTry(BounDesc,Loc,Own);
END; {CASE $01}
$02: IF RecdHash <> 0 THEN CoverHash(RecdHash,Own);
$03: IF ObjtHash <> 0 THEN CoverHash(ObjtHash,ObjtName);
$04,
$05: CoverTypeTry(FileType,Loc,Own);
$06: CoverTypeTry(T^.PFRes,Loc,Own);
$07: CoverTypeTry(SetBase,Loc,Own);
$08: CoverTypeTry(PtrBase,Loc,Own);
$09: BEGIN
CoverTypeTry(StrBase,Loc,Own);
CoverTypeTry(StrBound,Loc,Own);
END; {CASE $09}
$0C, $0D,
$0E: CoverTypeTry(Cmpat,Loc,Own);
$0F: IF AddrType(UImg,Cmpat) <> Nil THEN
IF Cmpat.UntLL <> Loc Then
Begin
CoverType(Cmpat.UntLL,Own);
{ now cover the SET descriptor that follows }
TT := TypePtr(PtrAdjust(@Cmpat,SizeOf(T^.Cmpat)));
If FormLL(UImg,TT) <> Loc Then
If NOT QueLoad
Then Inc(ECount) Else
Begin
A.LocLL := Loc; A.LocOwn := Own;
A.LocTyp := cvType; A.LocLvl := Level;
Enqueue(A);
End;
END; {CASE $0F}
END; {CASE tpTC}
END; {CoverType}
PROCEDURE CoverName(Loc, Own: LL); {.CP21}
VAR C: Char; D: DNamePtr; S: DStubPtr; T: TypePtr;
BEGIN {CoverName}
Repeat
{$IFDEF TESTDBG}
If (Loc < UImg^.UHIHT) OR (Loc > UImg^.UHPMT)
Then CoverFault(Loc);
CoverAudit('CoverName',Loc);
{$ENDIF}
D := AddrDict(UImg,Loc);
USymbol := D^.DSymb;
If NOT QueLoad
Then Inc(ECount) Else
Begin
A.LocLL := Loc; A.LocOwn := Own;
A.LocTyp := cvName; A.LocLvl := Level;
Enqueue(A);
End;
S := AddrStub(D);
C := Public(D^.DForm);
WITH S^ DO
CASE C OF {.CP20}
'P': IF AddrType(UImg,sPTD) <> Nil
THEN CoverType(sPTD.UntLL,0);
'Q': IF AddrType(UImg,sQTD) <> Nil
THEN CoverType(sQTD.UntLL,Loc);
'X': IF AddrType(UImg,sQTD) <> Nil
THEN CoverType(sQTD.UntLL,0);
'R': IF AddrType(UImg,sRTD) <> Nil
THEN CoverType(sRTD.UntLL,0);
'S': BEGIN
IF sSHT <> 0 THEN CoverHash(sSHT,Loc);
T := AddrProcType(S);
CoverType(FormLL(T,UImg),Loc);
IF (sSTp AND $02) <> 0 THEN
CoverInLine(FormLL(UImg,@T^.PFPar[T^.PNPrm+1]),Loc);
END; {CASE 'S'}
END; {CASE C}
Loc := D^.HLink;
Until Loc = 0;
END; {CoverName}
PROCEDURE CoverHash(Loc, Own: LL); {.CP31}
VAR HLim, I : LL; H : HashPtr; Cycle: Boolean;
BEGIN {CoverHash}
Cycle := False; I := Level;
While (I > 0) AND NOT Cycle DO Begin
Cycle := LvlSav[I] = Loc;
Dec(I);
End;
If Not Cycle Then
Begin
If NOT QueLoad
Then Inc(ECount) Else
Begin
A.LocLL := Loc; A.LocOwn := Own;
A.LocTyp := cvHash; A.LocLvl := Level;
Enqueue(A);
End;
If Level < LvlLim Then Inc(Level);
LvlSav[Level] := Loc;
{$IFDEF TESTDBG}
If (Loc < UImg^.UHIHT) OR (Loc >= UImg^.UHPMT)
Then CoverFault(Loc);
CoverAudit('CoverHash',Loc);
{$ENDIF}
H := AddrHash(UImg,Loc);
HLim := (H^.Bas DIV SizeOf(LL));
FOR I := 0 TO HLim DO
IF H^.Slt[I] <> 0 THEN CoverName(H^.Slt[I],Own);
Dec(Level);
End;
END; {CoverHash}
Begin {CalcCovers} {.CP32}
{$IFDEF TESTDBG}
ReWrite(Audit);
{$ENDIF}
Level := 0; ECount := 0; QueLoad := False;
USymbol := '';
If UImg <> Nil Then
CoverHash(UImg^.UHDHT,0); { Debug Rtn Hash Table }
DisposeQueue;
If ECount > 0 Then
Begin
CvrLimit := ECount + 2;
CvrSize := CvrLimit * SizeOf(CvrRec);
GetMem(CvrQue,CvrSize);
If CvrQue <> Nil Then
Begin
QueLoad := True;
A.LocLL := UImg^.UHIHT; A.LocOwn := 0;
A.LocTyp := cvHash; A.LocLvl := 0;
Enqueue(A);
CoverHash(UImg^.UHDHT,0);
CoverWrapUp;
End Else
Begin
CvrSize := 0;
CvrLimit := 0;
End;
End;
{$IFDEF TESTDBG}
Close(Audit);
{$ENDIF}
End; {CalcCovers}
{.PA} {
The following method uses the output of method "CalcCovers" to browse the
symbol dictionary and discover relations involving the CSeg Map, the PROC
Map, the Global VAR DSeg Map and the Typed CONST DSeg Map. The relations
can involve Fix-Up data, the Trace Table, the Source File List, and the
various code and data segments contained in the latter part of the unit
file. These relations are saved in the heap for later retrieval by the
print routines.
}
Procedure TUnit.IndexMaps; {.CP02}
Var NObj: Word;
{ This Procedure computes the size of each } {.CP39}
{ PROC and adds the result to the Xref map }
Procedure SizeProcs;
Var I, J, K : Word; Pc, Pp : MapTabPtr; Rp, Rc : RMapPtr;
Begin
I := 0; K := 0;
Rp := CvrRMaps[rPROC]; { Get RMap Proc Pointer }
If Rp <> Nil Then
Begin
Pp := Rp^.RMapTabPtr; { Get Proc Ref Pointer }
J := Rp^.RMapTabSiz; { Get Slot Count }
End Else
Begin Pp := Nil; J := 0 End;
While (Pp^[K].MapTyp <> mfPDLL) AND (K < J) Do Inc(K);
If K < J Then J := K;
Rc := CvrRMaps[rCSEG]; { Get RMap Cod Pointer }
If Rc <> Nil
Then Pc := Rc^.RMapTabPtr { Get CSeg Ref Pointer }
Else Pc := Nil;
If (J>0) AND (Pc <> Nil) Then
While I < J-1 Do With Pp^[I] Do Begin
If Pp^[I].MapCSM <> $FFFF Then
If Pp^[I].MapCSM = Pp^[I+1].MapCSM
Then Pp^[I].MapSiz := Pp^[I+1].MapEPT - Pp^[I].MapEPT
Else Begin
K := Pp^[I].MapCSM DIV SizeOf(CMapRec);
Pp^[I].MapSiz := Pc^[K].MapLod + Pc^[K].MapSiz - Pp^[I].MapEPT;
End;
Inc(I);
End;
If (Pp <> Nil) AND (J>0) Then
With Pp^[J-1] Do
If MapCSM <> $FFFF Then
Begin
K := MapCSM DIV SizeOf(CMapRec);
MapSiz := Pc^[K].MapLod + Pc^[K].MapSiz - MapEPT;
End;
End; {SizeProcs}
{ This Procedure Initializes the CSeg Xref Map } {.CP26}
{ and sets CSeg Load Points and Fix-Up Offsets }
Procedure PrimeCSegs;
Var Cx, Cn, I, N : Word; D : DMapTabPtr; LBaseC, LBaseD, LBaseF: Word;
C : CMapTabPtr; P : PMapPtr; Rmt, Rmv : MapTabPtr;
Begin
Rmt := CvrRMaps[rCSEG]^.RMapTabPtr;
N := CvrRMaps[rCSEG]^.RMapTabSiz;
Cn := CountCMapSlots(UImg);
C := AddrCMapTab(UImg);
LBaseC := 0; LBaseD := 0; LBaseF := 0;
If (C <> Nil) AND (Cn > 0) Then
For Cx := 0 To Cn-1 Do { First, we add Info from CSeg }
With C^[Cx], Rmt^[Cx] Do { Map to our CSeg MapRefTab and }
Begin { Calc Fix-Up Offsets }
MapTyp := mfCSEG;
MapSrc := 0;
MapLod := LBaseC; { Save Offset to Load Point }
MapSiz := CSegCnt; { Save Segment Byte Count }
MapFxI := LBaseF; { Save Offset to Fix-Ups }
MapFxJ := CSegRel; { Save Fix-Ups Byte Count }
Inc(LBaseC,CSegCnt);
Inc(LBaseF,CSegRel);
End;
{ Similarly for Typed Constant Data Segments } {.CP52}
Rmv := CvrRMaps[rCONS]^.RMapTabPtr;
N := CvrRMaps[rCONS]^.RMapTabSiz;
D := AddrDMapTab(UImg);
LBaseF := 0;
If D <> Nil Then
For Cx := 0 To N-1 Do { First, we add Info from DSeg }
With D^[Cx], Rmv^[Cx] Do { Map to our DSeg MapRefTab and }
Begin { Calc Fix-Up Offsets }
MapSrc := 0;
MapSiz := DSegCnt;
MapLod := LBaseD;
MapFxI := LBaseF;
MapFxJ := DSegRel;
Inc(LBaseD,DSegCnt);
Inc(LBaseF,DSegRel);
If DSegOwn <> 0 Then
Begin MapOwn := DSegOwn; MapTyp := mfTVMT End;
End;
{ Now, we do a similar job for the PROC Map }
Rmv := CvrRMaps[rPROC]^.RMapTabPtr;
N := CvrRMaps[rPROC]^.RMapTabSiz;
P := AddrPMapTab(UImg);
If P <> Nil Then
For Cx := 0 To N-1 Do
With P^[Cx], Rmv^[Cx] Do
Begin
MapCSM := CSegOfs;
MapEPT := CSegJmp;
MapSrc := 0;
If Odd(ProcWd2 SHR 2) Then { We Have a DLL Entry }
Begin
MapTyp := mfPDLL;
MapNdx := CSegJmp;
MapSrc := CSegOfs;
MapDLL := ProcWd2;
End Else
If MapCSM <> $FFFF Then
Begin
MapTyp := mfPROC;
I := MapCSM DIV SizeOf(CMapRec);
MapEPT := MapEPT + Rmt^[I].MapLod; { Relocate Entry Point }
End;
If Cx = 0 Then MapTyp := mfPRUI; { flag unit init code }
End;
End; { PrimeCSegs }
{ This Proc updates the CSeg Xref Table with data from the } {.CP58}
{ Trace and PROC Tables that allow us to determine which }
{ source file furnished the CSeg for the map entry. }
Procedure FinalCSegs;
Var Nc, I, Np, Sf, Sn: Word;
Ps, Ph: SrcFilePtr; Pt: TraceRecPtr; PRc, PRp: MapTabPtr;
Begin
Ps := AddrSrcTabOff(UImg,0); Ph := Ps; { Source File List }
Sf := 0; Sn := 0; { Total Src, non-Obj Files }
While Ps <> Nil Do Begin
Inc(Sf); { Inc Total Source Files }
If Ps^.SrcFlag <> $05 Then Inc(Sn); { Inc Non-Obj File Count }
Ps := AddrNxtSrc(UImg,Ps); { point to next src ntry }
End;
NObj := Sf - Sn; { Total *.OBJ Files } Ps := Ph; { Restore Ps }
If (NObj > 0) AND (CvrRMaps[rCSEG] <> Nil) Then { have *.OBJ's in lst }
Begin
PRc:= CvrRMaps[rCSEG]^.RMapTabPtr;
Nc := CvrRMaps[rCSEG]^.RMapTabSiz;
For I := 1 to Sn Do Ps := AddrNxtSrc(UImg,Ps);
For I := (Nc-NObj) To Nc-1 Do
With PRc^[I] Do Begin
MapSrc := FormLL(Ph,Ps);
Ps := AddrNxtSrc(UImg,Ps);
End; { *.OBJ Handler }
{ If Pascal Include Files are present, Only the Trace Table Knows }
{ and this is noted only if these files contain PROCs. This can }
{ be used to get the source file (actual) in these cases. Scan }
{ the trace table and compare its PROC pointer with PROC Name LL }
{ in our PROC Ref table. If match, then trace entry has source }
{ info that applies to this proc (which is part of some CSeg) and }
{ the PROC Ref entry has the CSeg Map Offset which we use to make }
{ the linkage to our CSeg Ref table to save source file offset. }
Pt := AddrTraceTab(UImg);
If CvrRMaps[rPROC] <> Nil Then If Nc > 0 Then
Begin
PRp := CvrRMaps[rPROC]^.RMapTabPtr;
Np := CvrRMaps[rPROC]^.RMapTabSiz;
While Pt <> Nil Do With Pt^ Do Begin {For ALL Trace Entries}
I := 0;
While I < Np Do With PRp^[I] Do Begin {For ALL PROC Entries }
If MapTyp <> mfPDLL Then
If MapOwn = Trname Then {Proc has Trace Entry }
Begin
PRc^[MapCSM DIV SizeOf(CMapRec)].MapSrc := Trfill;
I := Np; {quit loop and try next trace entry}
End;
Inc(I);
End;
Pt := AddrNxtTrace(UImg,Pt);
End;
End;
End;
End; {FinalCSegs}
{ This Procedure updates the CONST Xref Table with data from }{.CP54}
{ various sources to get offsets to Fix-Up data and to try to }
{ locate the file in the Source File List that contributed }
{ this entry. Any entry NOT defined in the Pascal Source will }
{ have mfNULL as its MapTyp. We will change such entries to }
{ mfXTRN and try to decide who spawned them. This problem is }
{ strictly undecidable. We can guess that a Fix-Up in some }
{ CSeg that references our entry is from the *.OBJ spawned the }
{ block, but that is the closest we can get to the truth. }
Procedure FinalCONST;
Var I, N : Word; HaveXtrn : Boolean; Rmt : MapTabPtr;
LBaseD, LBaseF: Word; Pt : TypePtr;
Begin
If CvrRMaps[rCONS] <> Nil Then
Begin
Rmt := CvrRMaps[rCONS]^.RMapTabPtr;
N := CvrRMaps[rCONS]^.RMapTabSiz;
HaveXtrn := False;
LBaseD := 0; LBaseF := 0;
If (N > 0) AND (Rmt <> Nil) Then
Begin
For I := 0 To N-1 Do With Rmt^[I] Do
Case MapTyp of
mfNULL:
If NObj > 0 Then
Begin
MapTyp := mfXTRN;
HaveXtrn := True;
End;
mfTVMT:
Begin
Pt := TypePtr(PtrAdjust(UImg,MapOwn));
If Pt <> Nil Then
If Pt^.ObjtDMTp = MapOfs
Then MapTyp := mfTDMT;
End;
End; {Case} { Fix-Up Offsets are now set }
{ Source File problem deferred until later }
End;
End;
If CvrRMaps[rVARS] <> Nil Then
Begin
Rmt := CvrRMaps[rVARS]^.RMapTabPtr; { Classify VARS Too }
N := CvrRMaps[rVARS]^.RMapTabSiz;
If (N > 0) AND (Rmt <> Nil) AND (NObj > 0)
Then For I := 0 To N-1 Do With Rmt^[I] Do
If MapTyp = mfNULL Then MapTyp := mfXTRN
End;
End; {FinalCONST}
Var I, J, DHT, IHT : Word; C : Char; {.CP29}
Pn : DNamePtr; Ps : DStubPtr; Pv : VarStubPtr; Pm: RMapPtr;
Pp : PMapRecPtr; Tc, Tv, Td : DMapRecPtr; V : CvrRec; Q, Qc : MapRefRec;
Ndx : MapClass; SystemUnit, InINTF : Boolean;
Begin {IndexMaps}
For Ndx := rPROC To rCONS Do
If CvrRMaps[Ndx] <> Nil Then CvrRMaps[Ndx]^.Done;
CvrRMaps[rCONS] := New(RMapPtr,Init(UImg^.UHDMT-UImg^.UHTMT));
CvrRMaps[rVARS] := New(RMapPtr,Init(UImg^.UHDLL-UImg^.UHDMT));
CvrRMaps[rPROC] := New(RMapPtr,Init(UImg^.UHCMT-UImg^.UHPMT));
CvrRMaps[rCSEG] := New(RMapPtr,Init(UImg^.UHTMT-UImg^.UHCMT));
DHT := UImg^.UHDHT; IHT := UImg^.UHIHT;
SystemUnit := IsSystemUnit(UImg);
(* If CvrRMaps[rCSEG]^.RMapTabSiz > 0 { Initialize CSeg Map Refs }
Then *) PrimeCSegs;
For I := 1 To CvrQueTail Do Begin { Get CONST/VAR Mapping }
V := CvrQue^[I];
If V.LocTyp = cvName Then
Begin
Tc := Ptr(Seg(UImg^),Ofs(UImg^)+UImg^.UHTMT); { CONS Map }
Tv := Ptr(Seg(UImg^),Ofs(UImg^)+UImg^.UHDMT); { DSeg Map }
Pn := Ptr(Seg(UImg^),Ofs(UImg^)+V.LocLL);
Ps := AddrStub(Pn); C := Public(Pn^.DForm);
If C = 'R' Then { a data instance of some kind } {.CP37}
Begin
If Ps^.sRAM < $02 Then { a global variable or typed const }
Begin
Pv := @Ps^.sRVF;
J := Pv^.TOB;
InINTF := (IHT = DHT) OR SystemUnit OR (DHT > V.LocLL);
If Ps^.sRAM = $00 Then
Begin { it's a Global Variable }
Pm := CvrRMaps[rVARS];
Pm^.FetchRef(Q,Pv^.TOB);
Td := Ptr(Seg(Tv^),Ofs(Tv^)+J);
Q.MapSiz := Td^.DSegCnt;
If InINTF Then Q.MapTyp := mfINTF
Else Q.MapTyp := mfIMPL;
Pm^.StoreRef(Q,Pv^.TOB);
End Else
Begin { it's a Typed Constant }
Pm := CvrRMaps[rCONS];
Pm^.FetchRef(Q,Pv^.TOB);
Td := Ptr(Seg(Tc^),Ofs(Tc^)+J);
If Td^.DSegOwn <> 0 Then Begin
Q.MapTyp := mfTVMT;
Q.MapOwn := Td^.DSegOwn; { Owner is OBJECT Name }
End Else
If V.LocLvl = 1
Then If InINTF Then Q.MapTyp := mfINTF
Else Q.MapTyp := mfIMPL
Else Begin
Q.MapTyp := mfNEST;
Q.MapOwn := V.LocOwn; { Owner is PROC scope }
End;
Pm^.StoreRef(Q,Pv^.TOB);
End; { Typed Constant }
End; { Variable/Constant }
End { Type 'R' Stub }
Else { Check for PROC Map } {.CP20}
If C = 'S' Then { It's a PROC ...... }
If (Ps^.sSTP AND $02) = 0 Then { ... AND NOT INLINE }
Begin
Pm := CvrRMaps[rPROC]; { Get Method Pointer }
Pm^.FetchRef(Q,Ps^.sSPM);
Q.MapOwn := V.LocLL; { Get PROC Name Offset }
Pm^.StoreRef(Q,Ps^.sSPM);
End; { Type 'S' Stub }
End; { DName Entry }
End; { FOR }
If CvrRMaps[rCSEG]^.RMapTabSiz > 0 Then FinalCSegs; { Finish CSeg Refs }
CvrRMaps[rPROC]^.SortPMap(CSegOrder); { Sort PROCS in Load Order }
SizeProcs; { Get Proc Size(Bytes) }
CvrRMaps[rPROC]^.SortPMap(PMapOrder); { Sort PROCS in PMap Order }
If CvrRMaps[rCONS] <> Nil Then FinalCONST; { Finish CONST Refs }
End; {IndexMaps}
(* E N D M E T H O D S *)
Function FindCover(U : UnitPtr) : TUnitPtr; {.CP11}
Var S : TUnitPtr;
Begin
FindCover := Nil; S := LstRoot;
While S <> Nil Do
If S^.UImg <> U Then S := S^.Link Else
Begin
FindCover := S;
S := Nil
End;
End; {FindCover}
{ Procedure Below Traps Pointer Violations } {.CP07}
PROCEDURE CheckPtrs(U, V: Pointer);
BEGIN
IF (U = Nil) OR (V = Nil) OR (Seg(U^) <> Seg(V^))
THEN RunError(215);
END; {CheckPtrs}
{ Function Below Computes an LL from two Pointers } {.CP09}
FUNCTION FormLL(Base, Ceil: Pointer): LL;
BEGIN
CheckPtrs(Base,Ceil);
IF Ofs(Base^) > Ofs(Ceil^)
THEN FormLL := LL(Ofs(Base^)-Ofs(Ceil^))
ELSE FormLL := LL(Ofs(Ceil^)-Ofs(Base^));
END;
{ Function Below Checks to See if Unit Name is "SYSTEM" } {.CP06}
FUNCTION IsSystemUnit(U: UnitPtr): Boolean;
BEGIN
IsSystemUnit := DNamePtr(Ptr(Seg(U^),Ofs(U^)+U^.UHUDH))^.DSymb = 'SYSTEM'
END;
{ Function Finds The Stub Belonging to a Dictionary Header } {.CP08}
FUNCTION AddrStub(Arg: DNamePtr): DStubPtr;
CONST PrefixSize = SizeOf(LL)+SizeOf(Char) + 1;
BEGIN
If Arg = Nil Then AddrStub := Nil Else
AddrStub := PtrAdjust(Arg,PrefixSize + Ord(Arg^.DSymb[0]))
END;
{ Function Below Gets Pointer to Hash Table } {.CP07}
FUNCTION AddrHash(U: UnitPtr; Hash: LL): HashPtr;
BEGIN
If U = Nil Then AddrHash := Nil Else
AddrHash := HashPtr(PtrAdjust(U,Hash))
END;
{ Function Below Gets Pointer to Dictionary Entry using LL } {.CP04}
FUNCTION AddrDict(U: UnitPtr; Hash: LL): DNamePtr;
BEGIN
If U = Nil Then AddrDict := Nil Else
AddrDict := DNamePtr(PtrAdjust(U,Hash))
END;
{ Function Below Gets Pointer to Type Descriptor if Local to Unit } {.CP15}
FUNCTION AddrType(U: UnitPtr; TypeLG: LG): TypePtr;
VAR D:DNamePtr; S: DStubPtr; R: LL;
BEGIN
AddrType := Nil;
If U <> Nil Then
Begin
D := AddrDict(U,U^.UHUDH); {point to our unit DE}
S := AddrStub(D); {point to its stub }
R := FormLL(U,S); {get offset to stub }
IF R = TypeLG.UntId {if offset matches }
THEN AddrType := TypePtr(PtrAdjust(U,TypeLG.UntLL));
End;
END;
{ Function Below Gets Pointer to Unit Descriptor for Type via LG } {.CP21}
FUNCTION AddrLGUnit(U: UnitPtr; TypeLG: LG): DNamePtr;
VAR D: DNamePtr; S: DStubPtr; R: LL;
BEGIN
D := AddrDict(U,U^.UHUDH); {point to our unit hdr}
S := AddrStub(D); {point to our stub }
R := FormLL(U,S); {get offset to stub }
IF (R <> 0) THEN
IF (TypeLG.UntID <> R) THEN {if offsets don't match }
REPEAT
D := AddrDict(U,S^.sYNU); {chain to next DE}
IF D^.DForm <> 'Y' THEN R := 0 ELSE {if next is unit }
BEGIN
S := AddrStub(D); {its stub address}
R := FormLL(U,S); {and stub offset }
END;
UNTIL (R = TypeLG.UntID) OR (R = 0); {match of end list }
IF R <> 0 THEN AddrLGUnit := D {we had a match }
ELSE AddrLGUnit := Nil; {we couldn't find it}
END;
{ Function Below Gets Pointer to Procedure Stub Type Descriptor }{.CP07}
FUNCTION AddrProcType(S: DStubPtr): TypePtr;
BEGIN
If S = Nil Then AddrProcType := Nil Else
AddrProcType := TypePtr(PtrAdjust(@S^.sSVM,SizeOf(S^.sSVM)))
END;
{ Function Below Gets Pointer to Next Entry in Source File List } {.CP21}
FUNCTION AddrNxtSrc(U: UnitPtr; Arg: SrcFilePtr): SrcFilePtr;
VAR J: LL; S: SrcFilePtr;
BEGIN
J := 0;
IF (U = Nil) OR (Arg = Nil) THEN AddrNxtSrc := Nil ELSE
BEGIN
J := FormLL(U,Arg);
IF J < U^.UHLSF
THEN AddrNxtSrc := Nil ELSE
IF NOT (J < U^.UHDBT)
THEN AddrNxtSrc := Nil ELSE
BEGIN
S := SrcFilePtr(PtrAdjust(Arg,8 + Ord(Arg^.SrcName[0])));
IF FormLL(U,S) < U^.UHDBT
THEN AddrNxtSrc := S
ELSE AddrNxtSrc := Nil
END
END
END;
{ Function Below Gets Pointer to Source File List Entry at Offset }{.CP09}
FUNCTION AddrSrcTabOff(U: UnitPtr; Offset: Word): SrcFilePtr;
BEGIN
AddrSrcTabOff := Nil;
If U <> Nil Then WITH U^ DO
IF (UHLSF+Offset) < UHDBT
THEN AddrSrcTabOff := SrcFilePtr(PtrAdjust(U,UHLSF+Offset));
END;
{ Function Below Gets Pointer to Next Entry in DLL List } {.CP21}
FUNCTION AddrNxtDLL(U: UnitPtr; Arg: DLLPtr): DLLPtr;
VAR J: LL; S: DLLPtr;
BEGIN
J := 0;
IF (U = Nil) OR (Arg = Nil) THEN AddrNxtDLL := Nil ELSE
BEGIN
J := FormLL(U,Arg);
IF J < U^.UHDLL
THEN AddrNxtDLL := Nil ELSE
IF NOT (J < U^.UHLDU)
THEN AddrNxtDLL := Nil ELSE
BEGIN
S := DLLPtr(PtrAdjust(Arg,5 + Ord(Arg^.DLLMod[0])));
IF FormLL(U,S) < U^.UHLDU
THEN AddrNxtDLL := S
ELSE AddrNxtDLL := Nil
END
END
END;
{ Function Below Gets Pointer to DLL List Entry at Offset } {.CP09}
FUNCTION AddrDLLTabOff(U: UnitPtr; Offset: Word): DLLPtr;
BEGIN
AddrDLLTabOff := Nil;
If U <> Nil Then WITH U^ DO
IF (UHDLL+Offset) < UHLDU
THEN AddrDLLTabOff := DLLPtr(PtrAdjust(U,UHDLL+Offset));
END;
{ Function Counts Number of Slots in PROC Map Table } {.CP06}
FUNCTION CountPMapSlots(U: UnitPtr): Integer;
BEGIN
CountPMapSlots := (U^.UHCMT-U^.UHPMT) DIV SizeOf(PMapRec);
END;
{ Function Gets Address of PROC Map Table } {.CP08}
FUNCTION AddrPMapTab(U: UnitPtr): PMapPtr;
BEGIN
IF CountPMapSlots(U) > 0
THEN AddrPMapTab := PMapPtr(PtrAdjust(U,U^.UHPMT))
ELSE AddrPMapTab := Nil
END;
{ Function Counts Number of Slots in CSeg Map Table } {.CP06}
FUNCTION CountCMapSlots(U: UnitPtr): Integer;
BEGIN
WITH U^ DO CountCMapSlots := (UHTMT-UHCMT) DIV SizeOf(CMapRec);
END;
{ Function Gets Address of CSeg Map Table } {.CP08}
FUNCTION AddrCMapTab(U: UnitPtr): CMapTabPtr;
BEGIN
IF CountCmapSlots(U) > 0
THEN AddrCMapTab := CMapTabPtr(PtrAdjust(U,U^.UHCMT))
ELSE AddrCMapTab := Nil
END;
{ Function Counts Number of DSeg Map Slots } {.CP06}
FUNCTION CountDMapSlots(U: UnitPtr): Integer;
BEGIN
WITH U^ DO CountDMapSlots := (UHDMT - UHTMT) DIV SizeOf(DMapRec)
END;
{ Function Gets Address of DSeg Map Table } {.CP08}
FUNCTION AddrDMapTab(U: UnitPtr): DMapTabPtr;
BEGIN
IF CountDMapSlots(U) > 0
THEN AddrDMapTab := DMapTabPtr(PtrAdjust(U,U^.UHTMT))
ELSE AddrDMapTab := Nil
END;
{ Function Below Gets Pointer to 1st Trace Table Entry or Nil } {.CP08}
FUNCTION AddrTraceTab(U: UnitPtr): TraceRecPtr;
BEGIN
IF U^.UHDBT = U^.UHZDA
THEN AddrTraceTab := Nil
ELSE AddrTraceTab := TraceRecPtr(PtrAdjust(U,U^.UHDBT))
END; {AddrTraceTab}
{ Function Below Gets Byte Count in TrExec Array } {.CP20}
FUNCTION GetTrExecSize(T: TraceRecPtr): Integer;
VAR i,k : Integer;
BEGIN
IF T = Nil THEN GetTrExecSize := 0 ELSE
BEGIN
k := T^.TrLNos; {number of lines in array}
i := 1; {prime scan line number }
WHILE i <= k DO BEGIN {still have lines to test}
IF T^.TrExec[i] = $80 THEN {if "escape byte" present}
BEGIN
Inc(k); {bump array limit }
Inc(i) {bump to byte count slot }
END;
Inc(i) {check next slot }
END;
GetTrExecSize := k; {final byte count }
END;
END;
{ Function Below Gets Pointer to next Trace Table Entry or Nil } {.CP14}
FUNCTION AddrNxtTrace(U: UnitPtr; T: TraceRecPtr): TraceRecPtr;
VAR k : Integer;
BEGIN
IF T = Nil THEN AddrNxtTrace := Nil ELSE
BEGIN
k := GetTrExecSize(T);
T := TraceRecPtr(PtrAdjust(@T^.TrExec[1],LL(k)));
IF FormLL(U,T) >= U^.UHZDA
THEN AddrNxtTrace := Nil
ELSE AddrNxtTrace := T
END
END; {AddrNxtTrace}
{ Function Below Gets Pointer to 1st Fixup Table Entry or Nil } {.CP17}
Type FixClass = (CodeFix, DataFix);
FUNCTION AddrFixUps(U: UnitPtr; C: FixClass): FixUpPtr;
VAR j : Word; S: TUnitPtr;
BEGIN
S := FindCover(U);
If S <> Nil Then
Begin
Case C Of
CodeFix: AddrFixUps := FixUpPtr(S^.UFXC);
DataFix: AddrFixUps := FixUpPtr(S^.UFXD);
Else AddrFixUps := Nil;
End
End Else AddrFixUps := Nil;
END; {AddrFixUps}
Function AddrCodeFixUps(U: UnitPtr): FixUpPtr; {.CP02}
Begin AddrCodeFixUps := AddrFixUps(U,CodeFix); End;
Function AddrDataFixUps(U: UnitPtr): FixUpPtr; {.CP02}
Begin AddrDataFixUps := AddrFixUps(U,DataFix); End;
Function AddrCodeArea(U: UnitPtr): Pointer; {.CP06}
Var S: TUnitPtr;
Begin
S := FindCover(U);
If S <> Nil Then AddrCodeArea := S^.UCod Else AddrCodeArea := Nil
End;
Function AddrDataArea(U: UnitPtr): Pointer; {.CP06}
Var S: TUnitPtr;
Begin
S := FindCover(U);
If S <> Nil Then AddrDataArea := S^.UDta Else AddrDataArea := Nil
End;
PROCEDURE SortProcRefs(Mode: SortMode); {.CP06}
Begin
If LstRoot <> Nil Then
If LstRoot^.CvrRMaps[rPROC] <> Nil
Then LstRoot^.CvrRMaps[rPROC]^.SortPmap(Mode);
End;
PROCEDURE FetchMapRef (VAR S : MapRefRec; {.CP10}
C : MapClass;
Offset: Word);
Var Q : TUnitPtr;
Begin
Q := LstRoot; S := NullMap;
If Q <> Nil Then
If Q^.CvrRMaps[C] <> Nil
Then Q^.CvrRMaps[C]^.FetchRef(S,Offset);
End;
PROCEDURE FetchSurveyRec (VAR S : SurveyRec); {.CP18}
Var Q : CvrRec;
Begin
S.LocTyp := cvNULL; S.LocLL := 0; S.LocOwn := 0; S.LocNxt := 0;
If LstRoot <> Nil Then With LstRoot^ Do
If UImg <> Nil Then If CvrQue <> Nil Then
Begin
If CvrQueHead < CvrQueTail Then
Begin
Inc(CvrQueHead);
Q := CvrQue^[CvrQueHead];
S.LocTyp := Q.LocTyp; S.LocLL := Q.LocLL;
S.LocOwn := Q.LocOwn; S.LocNxt := UImg^.UHPMT
End;
If CvrQueHead < CvrQueTail
Then S.LocNxt := CvrQue^[CvrQueHead+1].LocLL;
End;
End; {FetchSurveyRec}
Procedure PurgeAllUnits; {.CP12}
Var P, Q: TUnitPtr;
Begin
P := Nil; Q := LstRoot;
While Q <> Nil Do
Begin
P := Q^.Link;
Q^.Done;
Q := P;
End;
LstRoot := Nil;
End; {PurgeAllUnits}
Function FindUnit(N: _UnitName) : UnitPtr; {.CP12}
Var P : TUnitPtr; U : UnitPtr;
Begin
U := Nil; P := LstRoot;
While P <> Nil Do
If P^.Name <> N Then P := P^.Link Else
Begin
U := P^.UImg;
P := Nil
End;
FindUnit := U;
End;
PROCEDURE SurveyUnit(U : UnitPtr); {.CP11}
Var S : TUnitPtr;
BEGIN {SurveyUnit}
S := FindCover(U); { Locate Proper TUnit }
If S <> Nil Then
Begin
S^.CalcCovers; { Analyze Dictionary }
If S = LstRoot Then { If Initial Unit Then }
S^.IndexMaps; { Cross-Index All Maps }
End;
END; {SurveyUnit}
PROCEDURE ResolveLG(N: _UnitName; L: LG; VAR R: RespLG); {.CP19}
Var S : RespLG; U : UnitPtr; T : TUnitPtr; Q: CvrPtr;
W : Word;
Begin
S.Uptr := Nil; S.Ownr := $FFFF; U := FindUnit(N);
If U <> Nil Then
Begin
T := FindCover(U);
W := T^.QueuePos(L.UntLL);
Q := T^.CvrQue;
If NOT (W > T^.CvrQueTail) Then
If L.UntLL = Q^[W].LocLL Then
Begin
S.Uptr := U;
S.Ownr := Q^[W].LocOwn;
End;
End;
R := S;
End; { ResolveLG }
Var LoaderPath: _FileXpnd;
Procedure UnitLoader( Path : Dos.PathStr; {.CP12}
Name : _UnitName;
Optn : UnitMode;
VAR Core : Word;
VAR Locn : UnitPtr);
VAR SaveMode,UnitVersion : Word; U : UnitPtr;
FileId : _FileSpec;
FileDir : Dos.DirStr; FileName : Dos.NameStr;
FileExtn : Dos.ExtStr; FilePath : Dos.PathStr;
WorkArea : Array[0..3] Of _Paragraph;
UnitFile : File; EnvirPth : String;
Z : LdrVec;
Function UnitSize( U : UnitPtr) : LongInt; {.CP25}
VAR EyeBall : String[4]; I : Byte; Total : LongInt;
Begin
For I := 1 To 5 Do Begin
Z[I].LdrUpt := Nil; Z[I].LdrSiz := 0;
End;
Total := 0;
EyeBall[0] := Chr(SizeOf(EyeBall)-1);
Move(U^,EyeBall[1],SizeOf(EyeBall)-1);
If EyeBall = _UnitEye Then
Begin
Z[1].LdrSiz := (U^.UHZDA+$F) AND $FFF0; { ENTIRE Dictionary Size }
Z[2].LdrSiz := (U^.UHZCS+$F) AND $FFF0; { Size: All CSegs }
Z[3].LdrSiz := (U^.UHZDT+$F) AND $FFF0; { Size: All Typed CONSTS }
Z[4].LdrSiz := (U^.UHZFA+$F) AND $FFF0; { Size: All CSeg Fix-Ups }
Z[5].LdrSiz := (U^.UHZFT+$F) AND $FFF0; { Size: All CONS Fix-Ups }
For I := 1 To 5 Do Inc(Total,Z[I].LdrSiz); { Calc Unit Size }
If Optn = Partial Then
Begin
Z[1].LdrSiz := (U^.UHPMT+$F) AND $FFF0 ; { Dictionary Size }
For I := 2 To 5 Do Z[I].LdrSiz := 0; { Skip rest of unit }
End;
End;
UnitSize := Total; { Return Total Actual Size of Unit }
End; {UnitSize}
Function FileExists( N : _FileSpec) : Boolean; {.CP12}
Begin
FilePath := FSearch(N,EnvirPth);
If FilePath <> '' Then
Begin
FilePath := FExpand(FilePath);
FSplit(FilePath,FileDir,FileName,FileExtn);
FileId := N;
FileExists := True
End
Else FileExists := False;
End; {FileExists}
Procedure OpenUnitFile(P : Dos.PathStr; N : _FileSpec); {.CP08}
Begin
Assign(UnitFile,P+N);
SaveMode := FileMode;
FileMode := 0;
Reset(UnitFile,SizeOf(_Paragraph));
FileMode := SaveMode;
End;
Procedure InstallUnit(Z: LdrVec; N : _UnitName); {.CP18}
Var Sk, Sr : Word; T, V : TUnitPtr;
Begin
T := New(TUnitPtr,Init(N,Z)); { build placeholder }
If T <> Nil Then
Begin
If LstRoot = Nil
Then LstRoot := T Else { add to chain }
Begin
V := LstRoot;
While V^.Link <> Nil Do V := V^.Link;
V^.Link := T;
End;
LoaderPath := FileDir+FileId;
Core := Sk; { Say How Much of Unit Loaded }
Locn := T^.UImg; { Point to Unit Load Address }
End;
End; {InstallUnit}
Procedure CheckLibrary(N: _UnitName); {.CP17}
Var I: Word; Su, Sf, Fp, Tp: LongInt;
U: UnitPtr; Ps: DStubPtr; Pn: DNamePtr; U1: Pointer;
Function FetchUnitSegment(Posn: LongInt; BytCnt: Word): Pointer;
Var Pf : Pointer;
Begin
Pf := Nil;
If (Sf > 0) AND (BytCnt > 0) Then
Begin
Seek(UnitFile,Posn);
GetMem(Pf,BytCnt);
If Pf <> Nil
Then BLockRead(UnitFile,Pf^,BytCnt SHR 4);
End;
FetchUnitSegment := Pf;
End;
Begin {CheckLibrary} {.CP43}
OpenUnitFile(FileDir,FileId); { Open the File }
Sf := FileSize(UnitFile); { Get File Size (rcds) }
Fp := 0; { File Pointer = 0 }
While Fp < Sf Do Begin { Browse the Library }
Seek(UnitFile,Fp); { Locate Unit }
BlockRead(UnitFile,WorkArea,4); { Read Header }
U := @WorkArea; { Point to it }
Su := UnitSize(U); { Get Unit Size - Bytes }
If Su > 0 Then { If Unit <> Nil}
Begin
Z[1].LdrUpt := FetchUnitSegment(Fp,Z[1].LdrSiz);
If Z[1].LdrUpt <> Nil Then
Begin
Tp := Z[1].LdrSiz SHR 4 + Fp;
U := UnitPtr(Z[1].LdrUpt);
Pn := DNamePtr(Ptr(Seg(U^),Ofs(U^)+U^.UHUDH));
Ps := AddrStub(Pn);
{ Check name for match, if nested check for version match }
If (N <> Pn^.DSymb) OR
((Optn = Partial) AND (Ps^.sYCS <> UnitVersion)) Then
Begin
FreeMem(U,Z[1].LdrSiz); { Wrong Unit / Version }
Inc(Fp,Su SHR 4);
End Else
Begin { load remaining segments }
For I := 2 To 5 Do Begin
U := FetchUnitSegment(Tp,Z[I].LdrSiz);
If U <> Nil Then Tp := Z[I].LdrSiz SHR 4 + Tp;
If U <> Nil Then Z[I].LdrUpt := U;
End;
InstallUnit(Z,N);
Fp := Sf { terminates browse process }
End;
End
End Else Fp := Sf; { skip out if invalid unit }
End;
Close(UnitFile);
End; {CheckLibrary}
VAR I : Word; {.CP12}
Begin {UnitLoader}
UnitVersion := Core;
Core := 0;
Locn := Nil;
LoaderPath := '';
If Path = ''
Then EnvirPth := GetEnv('PATH')
Else EnvirPth := Path;
If FileExists(Name+'.TPU') Then CheckLibrary(Name) Else
If FileExists(_Lib_Nam) Then CheckLibrary(Name);
End; {UnitLoader}
Function AnalyzeUnit(Name: _UnitName; Path: String): UnitPtr; {.CP36}
Var U, Z: UnitPtr; N: DNamePtr; S: DStubPtr; USize: Word;
Begin
UnitLoader(Path,Name,Entire,USize,U); { Load Entire Unit }
AnalyzeUnit := U; { Save Unit Pointer }
If U <> Nil Then
Begin
PutTxt('Unit ('+Name+')');
SetCol(17);
PutTxt(' loaded from '+LoaderPath);
SetCol(1);
SurveyUnit(U); { Analyze Unit }
Base_Code := (U^.UHZDA + $F) AND Masker;
Base_Data := (U^.UHZCS + $F) AND Masker + Base_Code;
Base_FixC := (U^.UHZDT + $F) AND Masker + Base_Data;
Base_FixD := (U^.UHZFA + $F) AND Masker + Base_FixC;
N := DNamePtr(PtrAdjust(U,U^.UHUDH)); { Point to its name }
S := AddrStub(N); { Point to its stub }
While S^.sYNU <> 0 Do { if successor unit }
Begin
N := DNamePtr(PtrAdjust(U,S^.sYNU)); { Point to Name }
S := AddrStub(N); { Point to Stub }
USize := S^.sYCS; { Load Version }
UnitLoader(Path,N^.DSymb,Partial,USize,Z); { Load Partial }
If Z <> Nil Then
Begin
PutTxt('Unit ('+N^.DSymb+')');
SetCol(17);
PutTxt(' loaded from '+LoaderPath);
SetCol(1);
SurveyUnit(Z); { Get its Cover }
End;
End; { Until all Units Handled }
End;
End; {AnalyzeUnit}
{$IFDEF TESTDBG} {.CP07}
Begin
ExitSave := ExitProc;
ExitProc := @MyExit;
Assign(Audit,'Audit.Lst');
{$ENDIF}
END.